Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue36/mixin/MixInClasses.pas

Pascal/Delphi Source File | 1998-04-27 | 13.0 KB | 568 lines

unit MixInClasses;

interface

uses
  Classes, Controls, StdCtrls, ComCtrls, Messages, Windows, Dialogs;

type

  TSAChangeType = (sacSingleItemChange,
      sacCurrentChange,
      sacMajorChange,
      sacClosingDown);

  IKnowsObject = interface(IUnknown)
    function ObjectOfInterface: TObject;
  end;

  IStringArrayClient = interface(IKnowsObject)
    procedure StringArrayChange(ChangeType: TSAChangeType);
  end;

  TStringArray = class(TPersistent)
  private
    FCurrent:         Integer;
    ClientList:       TList;
    StrList:          TStringList;
    UpdateCount:      Integer;
  private
    function GetCount: Integer;
    function Get(Index: Integer): String;
    procedure NotifyClients(ChangeType: TSAChangeType);
    procedure Put(Index: Integer; const Value: String);
    procedure SetCount(Value: Integer);
    procedure SetCurrent(Index: Integer);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure BeginUpdate;
    procedure Clear;
    procedure EndUpdate;
    procedure RegisterClient(C: IStringArrayClient);
    procedure UnregisterClient(C: IStringArrayClient);
  public
    property Current: Integer read FCurrent write SetCurrent;
    property Count: Integer read GetCount write SetCount;
    property Strings[Index: Integer]: String read Get
      write Put; default;
  end;

  TSATrackBar = class(TTrackBar, IStringArrayClient)
  private
    FStringArray:     TStringArray;
  private
    function GetMax: Integer;
    function GetPosition: Integer;
    function GetSelStart: Integer;
    function GetSelEnd: Integer;
    procedure SetStringArray(SA: TStringArray);
    procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function QueryInterface(const IID: TGUID; out Obj): Integer;
      stdcall;
    function ObjectOfInterface: TObject;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure StringArrayChange(ChangeType: TSAChangeType);
  public
    property StringArray: TStringArray read FStringArray
        write SetStringArray;
  published
    property Max: Integer read GetMax;
    property Position: Integer read GetPosition;
    property SelStart: Integer read GetSelStart;
    property SelEnd: Integer read GetSelEnd;
  end;

  TSAEdit = class(TEdit, IStringArrayClient)
  private
    FStringArray:     TStringArray;
  private
    procedure Change; override;
    procedure CreateWnd; override;
    procedure SetStringArray(SA: TStringArray);
    procedure StringArrayChange(ChangeType: TSAChangeType);
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function QueryInterface(const IID: TGUID; out Obj): Integer;
      stdcall;
    function ObjectOfInterface: TObject;
  public
    destructor Destroy; override;
  public
    property StringArray: TStringArray read FStringArray
        write SetStringArray;
  end;

  TSAListBox = class(TCustomListBox, IStringArrayClient)
  private
    FStringArray: TStringArray;
  private
    procedure SetStringArray(SA: TStringArray);
    procedure StringArrayChange(ChangeType: TSAChangeType);
    procedure CNCommand(var Msg: TWMCommand);
        message CN_COMMAND;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    function QueryInterface(const IID: TGUID; out Obj): Integer;
      stdcall;
    function ObjectOfInterface: TObject;
  public
    destructor Destroy; override;
  public
    property StringArray: TStringArray read FStringArray
        write SetStringArray;
  end;

implementation

// -------- TStringArray --------

procedure TStringArray.Assign(Source: TPersistent);
var
  I:      Integer;
  Max:    Integer;
begin
  if (Source is TStrings) or (Source is TStringArray) then
  begin
    BeginUpdate;
    try
      Max := TStrings(Source).Count;
      if StrList.Count < Max then
        Max := StrList.Count;
      for I := 0 to (Max - 1) do
        if Source is TStrings then
          StrList[I] := TStrings(Source)[I]
        else
          StrList[I] := TStringArray(Source)[I];
      for I := Max to (StrList.Count - 1) do
        StrList[I] := '';
    finally
      EndUpdate; // which calls NotifyClients
    end;
  end
  else
    inherited Assign(Source);
end;

procedure TStringArray.AssignTo(Dest: TPersistent);
begin
  if Dest is TStrings then
  begin
    Dest.Assign(StrList);
    Exit;
  end;
  inherited AssignTo(Dest);
end;

procedure TStringArray.BeginUpdate;
begin
  Inc(UpdateCount);
end;

procedure TStringArray.Clear;
begin
  if StrList.Count <> 0 then
  begin
    StrList.Clear;
    FCurrent := -1;
    NotifyClients(sacMajorChange);
  end;
end;

constructor TStringArray.Create;
begin
  inherited Create;
  ClientList := TList.Create;
  StrList := TStringList.Create;
  FCurrent := -1;
end;

destructor TStringArray.Destroy;
var
  I:  Integer;
begin
  for I := ClientList.Count - 1 downto 0 do
    IStringArrayClient(ClientList[I]).
        StringArrayChange(sacClosingDown);
  ClientList.Free;
  StrList.Free;
  inherited Destroy;
end;

procedure TStringArray.EndUpdate;
begin
  Dec(UpdateCount);
  if UpdateCount = 0 then
    NotifyClients(sacMajorChange);
end;

function TStringArray.GetCount: Integer;
begin
  Result := StrList.Count;
end;

function TStringArray.Get(Index: Integer): String;
begin
  Result := StrList[Index];
end;

procedure TStringArray.NotifyClients(ChangeType: TSAChangeType);
var
  I:      Integer;
begin
  if UpdateCount = 0 then
    for I := 0 to (ClientList.Count - 1) do
      IStringArrayClient(ClientList[I]).
          StringArrayChange(ChangeType);
end;

procedure TStringArray.Put(Index: Integer; const Value: String);
begin
  if StrList[Index] <> Value then
  begin
    StrList[Index] := Value;
    NotifyClients(sacSingleItemChange);
  end;
end;

procedure TStringArray.RegisterClient(C: IStringArrayClient);
begin
  //ShowMessage('Connecting ' + C.ObjectOfInterface.ClassName);
  ClientList.Add(Pointer(C));
  C.StringArrayChange(sacMajorChange);
end;

procedure TStringArray.SetCount(Value: Integer);
var
  I: Integer;
begin
  if Value <> StrList.Count then
  begin
    if Value < StrList.Count then
      for I := (StrList.Count - 1) downto Value do
        StrList.Delete(I)
    else
      while (StrList.Count < Value) do
        StrList.Add('');
    if (FCurrent = -1) and (Value > 0) then
      FCurrent := 0
    else if (FCurrent <> -1) and (Value = 0) then
      FCurrent := -1
    else if FCurrent > (Value - 1) then
      FCurrent := Value - 1;
    NotifyClients(sacMajorChange);
  end;
end;

procedure TStringArray.SetCurrent(Index: Integer);
begin
  if Index <> FCurrent then
  begin
    if Index < 0 then
      Index := 0
    else if Index > (StrList.Count - 1) then
      Index := StrList.Count - 1;
    FCurrent := Index;
    NotifyClients(sacCurrentChange);
  end;
end;

procedure TStringArray.UnregisterClient(C: IStringArrayClient);
begin
  //ShowMessage('Disconnecting ' + C.ObjectOfInterface.ClassName);
  ClientList.Remove(Pointer(C));
end;

// -------- TSATrackBar --------

constructor TSATrackBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  inherited Max := 0;
  inherited SelEnd := 0;
end;

procedure TSATrackBar.CNHScroll(var Message: TWMHScroll);
begin
  inherited;
  if FStringArray <> nil then
    FStringArray.Current := Position;
end;

procedure TSATrackBar.CNVScroll(var Message: TWMVScroll);
begin
  inherited;
  if FStringArray <> nil then
    FStringArray.Current := Position;
end;

destructor TSATrackBar.Destroy;
begin
  StringArray := nil;
  inherited Destroy;
end;

function TSATrackBar.GetMax;
begin
  Result := inherited Max;
end;

function TSATrackBar.GetPosition;
begin
  Result := inherited Position;
end;

function TSATrackBar.GetSelStart: Integer;
begin
  Result := inherited SelStart;
end;

function TSATrackBar.GetSelEnd: Integer;
begin
  Result := inherited SelEnd;
end;

procedure TSATrackBar.SetStringArray(SA: TStringArray);
begin
  if SA <> FStringArray then
  begin
    if SA = nil then
    begin
      FStringArray.UnregisterClient(Self);
      FStringArray := nil;
      inherited Max := 0;
      inherited SelEnd := 0;
    end
    else
    begin
      if FStringArray <> nil then
        FStringArray.UnregisterClient(Self);
      FStringArray := SA;
      FStringArray.RegisterClient(Self);
    end;
  end;
end;

procedure TSATrackBar.StringArrayChange(ChangeType: TSAChangeType);
begin
  if FStringArray <> nil then
  begin
    case ChangeType of
      sacCurrentChange:
        inherited Position := FStringArray.Current;
      sacMajorChange:
      begin
        if FStringArray.Count = 0 then
        begin
          inherited Max := 0;
          inherited SelEnd := 0;
        end
        else
        begin
          inherited Max := FStringArray.Count - 1;
          inherited SelEnd := inherited Max;
          inherited Position := FStringArray.Current;
        end;
      end;
      sacClosingDown:
        StringArray := nil;
    end;
  end;
end;

function TSATrackBar._AddRef: Integer;
begin
  Result := 0;
end;

function TSATrackBar._Release: Integer;
begin
  Result := 0;
end;

function TSATrackBar.QueryInterface(const IID: TGUID; out Obj):
  Integer;
begin
  Result := 0;
end;

function TSATrackBar.ObjectOfInterface: TObject;
begin
  Result := Self;
end;

// -------- TSAEdit --------

procedure TSAEdit.Change;
begin
  inherited;
  if (FStringArray <> nil) and (FStringArray.FCurrent <> -1) then
    FStringArray[FStringArray.FCurrent] := Text;
end;

procedure TSAEdit.CreateWnd;
var
  RO: Boolean;
begin
  inherited CreateWnd;
  RO := (FStringArray = nil) or ReadOnly;
  SendMessage(Handle, EM_SETREADONLY, Ord(RO), 0);
end;

destructor TSAEdit.Destroy;
begin
  StringArray := nil;
  inherited Destroy;
end;

procedure TSAEdit.SetStringArray(SA: TStringArray);
begin
  if SA <> FStringArray then
  begin
    if SA = nil then
    begin
      FStringArray.UnregisterClient(Self);
      FStringArray := nil;
      Text := '';
      if HandleAllocated then
        SendMessage(Handle, EM_SETREADONLY, Ord(True), 0);
    end
    else
    begin
      if FStringArray <> nil then
        FStringArray.UnregisterClient(Self);
      FStringArray := SA;
      FStringArray.RegisterClient(Self);
    end;
  end;
end;

procedure TSAEdit.StringArrayChange(ChangeType: TSAChangeType);
var
  RO:     Boolean;
begin
  if ChangeType = sacClosingDown then
  begin
    StringArray := nil;
    Exit;
  end;
  if FStringArray.Count = 0 then
  begin
    Text := '';
    RO := True;
  end
  else
  begin
    Text := FStringArray[FStringArray.Current];
    RO := ReadOnly;
  end;
  if HandleAllocated then
    SendMessage(Handle, EM_SETREADONLY, Ord(RO), 0);
end;

function TSAEdit._AddRef: Integer;
begin
  Result := 0;
end;

function TSAEdit._Release: Integer;
begin
  Result := 0;
end;

function TSAEdit.QueryInterface(const IID: TGUID; out Obj):
  Integer;
begin
  Result := 0;
end;

function TSAEdit.ObjectOfInterface: TObject;
begin
  Result := Self;
end;

// -------- TSAListBox --------

destructor TSAListBox.Destroy;
begin
  StringArray := nil;
  inherited Destroy;
end;

procedure TSAListBox.CNCommand(var Msg: TWMCommand);
begin
  inherited;
  if (Msg.NotifyCode = LBN_SELCHANGE) and (FStringArray <> nil) then
    FStringArray.Current := ItemIndex;
end;


procedure TSAListBox.SetStringArray(SA: TStringArray);
begin
  if SA <> FStringArray then
  begin
    if SA = nil then
    begin
      FStringArray.UnregisterClient(Self);
      FStringArray := nil;
      Clear;
    end
    else
    begin
      if FStringArray <> nil then
        FStringArray.UnregisterClient(Self);
      FStringArray := SA;
      FStringArray.RegisterClient(Self);
    end;
  end;
end;

procedure TSAListBox.StringArrayChange(ChangeType: TSAChangeType);
begin
  case ChangeType of
    sacSingleItemChange:
      Items[FStringArray.Current] :=
          FStringArray[FStringArray.Current];
    sacCurrentChange:
      ItemIndex := FStringArray.Current;
    sacMajorChange:
    begin
      Items.Assign(FStringArray);
      if FStringArray.Count > 0 then
        ItemIndex := FStringArray.Current;
    end;
    sacClosingDown:
      StringArray := nil;
  end;
end;

function TSAListBox._AddRef: Integer;
begin
  Result := 0;
end;

function TSAListBox._Release: Integer;
begin
  Result := 0;
end;

function TSAListBox.QueryInterface(const IID: TGUID; out Obj):
  Integer;
begin
  Result := 0;
end;

function TSAListBox.ObjectOfInterface: TObject;
begin
  Result := Self;
end;

end.